perm filename SMOOTH.F4[MSS,LCS]4 blob
sn#103261 filedate 1974-05-20 generic text, type T, neo UTF8
00010 SUBROUTINE SMOOTH(JQ)
00020 COMMON/ED/KX,NEXT,NN,NX,NY,J/LL/L
00050 COMMON /RC/MCLEF(400),IST(4000)
00060 COMMON /RZ/RSZ,IPLT,RJB,CENTR
00080 COMMON /FL/IC,NJ,NQ,RZ,IXRX,XGP,RXGP
00100 DIMENSION BUF2(700),SX(512),SY(512)
00105 COMMON/NFF/NE(513)
00110 DATA INC/10/
00120 RR=RSZ
00130 CC IF(IPLT.EQ.0)RR=RR*1.7
00200 COMMON X(100),Y(100),N,X1(512),Y1(512),S(100),K
00202 IF(IPLT.EQ.0.AND.JQ.EQ.0)CALL DPYSET(1,IST,4000)
00205 IF(JQ.NE.' ')CALL HYDPOG(1)
00210 JL=0
00220 NOFIL=-1
00225 IF(JQ.EQ.0)NOFIL=0
00230 100 JY=2
00300 IF(IPLT.EQ.0)CALL DPYSET(3,BUF2,700)
00305 J=MCLEF(1)
00310 7 JX=J
00320 8 KX=0
00400 DO 1 K=JY,J
00600 CALL UNPACK(K,JA,JB,MCLEF)
00602 IF(L.GE.100000000.AND.K.GT.JY)GO TO 6
00603 C JUMP WHEN INVIS. VECT.
00605 KX=KX+1
00610 X(KX)=JA+RJB
00620 1 Y(KX)=JB+CENTR
00630 9 X(KX+1)=999.
01300 4 N=KX
01900 CALL SS
02075 JL=JL+1
02077 JK=JL
02080 SX(JL)=X1(1)*RR
02085 SY(JL)=Y1(1)*RR
02100 CALL LINES(X1(1),Y1(1),3)
02200 DO 5 K=2,512,INC
02210 JL=JL+1
02255 SX(JL)=X1(K)*RR
02277 SY(JL)=Y1(K)*RR
02300 NE(JL)=0
02350 5 CALL LINES(X1(K),Y1(K),2)
02353 IF(SX(JL).NE.SX(JK))SX(JK)=SX(JL)
02356 IF(SY(JL).NE.SY(JK))SY(JK)=SY(JL)
02360 NE(JK)=3
02380 C FOR INVIS. VECTOR
02400 IF(IPLT.EQ.0)CALL DPYOUT(3)
02406 10 IF(JX.NE.J)GO TO 7
02420 CALL SETPOG(1)
02500 IF(NOFIL)RETURN
02600 200 NE(1)=JL
02800 CALL FILLQ(SX,SY,NE)
03000 RETURN
05200 6 JY=K
05300 JX=JY
05400 GO TO 9
05500 END
05600
05700 SUBROUTINE EDTYP(K,X,Y,JJJ)
05800 TYPE 57
05900 ACCEPT 1,K,X,Y
06000 IF(K.NE.' ')JJJ=0
06100 IF(K.EQ.':'.OR.JJJ)GO TO 2
06200 C TYPE "A" OR ":" TO ALTER
06300 IF(K.NE.'G')RETURN
06400 JJJ=-1
06500 2 K='A'
06700 57 FORMAT(' TYPE D, A, I OR X ',$)
06750 C M N1, N2 = MOVE SEGS N1 THROUGH N2.
06800 1 FORMAT(A1,2F)
06900 END
07000
07100 SUBROUTINE ITYP
07110 COMMON /RZ/RSZ,IPLT,RJB,CENTR
07200 COMMON/ED/K,NEXT,NN,NX,NY,J
07210 A=STPT(FLOAT(NX),RJB)
07220 B=STPT(FLOAT(NY),CENTR)
07300 TYPE 1,NN,A,B
07500 1 FORMAT(I4,')',2F6.0)
07600 END
07700
07800 SUBROUTINE FILLQ(Q,R,N)
07900 DIMENSION Q(1),R(1),N(1)
07955 COMMON /RZ/RSZ,IPLT,RJB,CENTR
08000 M=6
08100 IF(IPLT)M=1
08200 1 RZ=RSZ
08250 RSZ=1.0
08300 CC IF(IPLT.EQ.0)RSZ=1./1.7
08400 CALL FILLER(Q,R,N,M)
08500 RSZ=RZ
08510 IF(IPLT.GE.0)CALL DPYOUT(1)
08600 END
09000
09100 SUBROUTINE SAVE(M)
09200 DIMENSION M(1)
09300 J=7
09400 L=8
09500 DO 12 K=1,M(1),8
09600 IF(K+J.LT.M(1))GO TO 12
09700 J=M(1)-K
09800 L=J+1
09900 12 WRITE(1,11)L,(M(NM),NM=K,K+J)
10000 RETURN
10100 11 FORMAT(' 9999',I3,8I10)
10200 END